home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / tptc16.zip / TPCDECL.INC < prev    next >
Text File  |  1993-01-04  |  13KB  |  583 lines

  1.  
  2. (*
  3.  * TPTC - Turbo Pascal to C translator
  4.  *
  5.  * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
  6.  *
  7.  *)
  8.  
  9. (********************************************************************)
  10. (*
  11.  * process pascal data type specifications
  12.  *
  13.  *)
  14.  
  15. function psimpletype: string80;
  16.    {parse a simple (single keyword and predefined) type; returns the
  17.     translated type specification; sets the current data type}
  18. var
  19.    ts: string80;
  20.    sym: symptr;
  21.  
  22. begin
  23.    ts := '';
  24.  
  25.    repeat
  26.       if (tok = 'CHAR') or (tok = 'BYTE') then
  27.       begin
  28.          curtype := s_char;
  29.          cursuptype := ss_scalar;
  30.          curlimit := 255;
  31.       end
  32.       else
  33.  
  34.       if tok = 'STRING' then
  35.       begin
  36.          curtype := s_string;
  37.          cursuptype := ss_scalar;
  38.          curlimit := 255;
  39.       end
  40.       else
  41.  
  42.       if tok = 'TEXT' then
  43.       begin
  44.          curtype := s_file;
  45.          cursuptype := ss_scalar;
  46.          curlimit := 0;
  47.       end
  48.       else
  49.  
  50.       if tok = 'LONGINT' then
  51.       begin
  52.          curtype := s_long;
  53.          cursuptype := ss_scalar;
  54.          curlimit := maxint;
  55.       end
  56.       else
  57.  
  58.       if tok = 'BOOLEAN' then
  59.       begin
  60.          curtype := s_int;
  61.          cursuptype := ss_scalar;
  62.          curlimit := maxint;
  63.       end
  64.       else
  65.  
  66.       if tok = 'INTEGER' then
  67.       begin
  68.          curtype := s_int;
  69.          cursuptype := ss_scalar;
  70.          curlimit := maxint;
  71.       end
  72.       else
  73.  
  74.       if tok = 'REAL' then
  75.       begin
  76.          curtype := s_double;
  77.          cursuptype := ss_scalar;
  78.          curlimit := maxint;
  79.       end;
  80.  
  81.       sym := locatesym(ltok);
  82.       if sym <> nil then
  83.       begin
  84.          curtype := sym^.symtype;
  85.          cursuptype := sym^.suptype;
  86.          curlimit := sym^.limit;
  87.       end;
  88.  
  89.       if ts <> '' then
  90.          ts := ts + ' ' + ltok
  91.       else
  92.          ts := ltok;
  93.       gettok;
  94.  
  95.    until (tok = ';') or (tok = ')') or (tok = '=') or (tok = '}');
  96.  
  97.    psimpletype := ts;
  98. end;
  99.  
  100.  
  101. (********************************************************************)
  102. procedure pdatatype(stoclass: anystring;
  103.                     var vars: paramlist;
  104.                     prefix:   anystring;
  105.                     suffix:   anystring;
  106.                     addsemi:  boolean);
  107.    {parse any full data type specification;  input is a list of variables
  108.     to be declared with this data type; stoclass is a storage class prefix
  109.     (usually 'static ', '', 'typedef ', or 'extern '.  prefix and suffix
  110.     are variable name modifiers used in pointer and subscript translations;
  111.     recursive for complex data types}
  112.  
  113. const
  114.    forward_typedef: anystring = '';
  115.    forward_undef:   anystring = '';
  116.  
  117. var
  118.    i:      integer;
  119.    ts:     anystring;
  120.    sym:    symptr;
  121.  
  122.  
  123.    procedure pvarlist;
  124.    var
  125.       i: integer;
  126.    begin
  127.       for i := 1 to vars.n do
  128.       begin
  129.          newsym(vars.id[i],curtype,cursuptype,-1,0,curlimit);
  130.  
  131.          write(ofd[level],' ',prefix,vars.id[i],suffix);
  132.          if i < vars.n then
  133.             write(ofd[level],',');
  134.       end;
  135.    end;
  136.  
  137.  
  138.    procedure parray;
  139.    begin
  140.       gettok;     {consume the ARRAY}
  141.       gettok;     {consume the [}
  142.  
  143.       ts := pexpr;   {consume the lower subscript expression}
  144.       if tok = '..' then
  145.       begin
  146.          gettok;   {consume the ..}
  147.          ts := pexpr;
  148.       end;
  149.  
  150.       sym := locatesym(ts);
  151.       if sym <> nil then
  152.          if (sym^.limit > 0) and (sym^.suptype <> ss_const) then
  153.             ts := ' /* ' + ts + ' */ ' + ftoa(sym^.limit,0,0);
  154.  
  155.       suffix := '[' + ts + '+1]'; {increment array size by one}
  156.  
  157.       gettok;     {consume the ]}
  158.       gettok;     {consume the OF}
  159.  
  160.       cursuptype := ss_array;
  161.    end;
  162.  
  163.  
  164.    procedure pstring;
  165.    begin
  166.       gettok;     {consume the STRING}
  167.  
  168.       if tok = '[' then
  169.       begin
  170.          gettok;     {consume the [}
  171.  
  172.          ts := pexpr;
  173.          suffix := suffix + '[' + ts + '+1]'; {increment string size by one}
  174.  
  175.          gettok;     {consume the ]}
  176.       end
  177.       else
  178.          suffix := suffix + '[STRSIZ]';
  179.  
  180.       write(ofd[level],stoclass,LJUST('char',identlen) );
  181.       curtype := s_string;
  182.       pvarlist;
  183.    end;
  184.  
  185.  
  186.    procedure ptext;
  187.    begin
  188.       gettok;     {consume the TEXT}
  189.  
  190.       if tok = '[' then
  191.       begin
  192.          gettok;     {consume the [}
  193.          ts := pexpr;
  194.          gettok;     {consume the ]}
  195.       end;
  196.  
  197.       write(ofd[level],stoclass,LJUST('text',identlen));
  198.       curtype := s_file;
  199.       pvarlist;
  200.    end;
  201.  
  202.  
  203.    procedure pfile;
  204.    begin
  205.       gettok;     {consume the FILE}
  206.  
  207.       if tok = 'OF' then
  208.       begin
  209.          gettok;     {consume the OF}
  210.          ts := tok;
  211.          gettok;     {consume the recordtype}
  212.       end;
  213.  
  214.       write(ofd[level],stoclass,LJUST('int',identlen),' /* file of ',ts,' */ ');
  215.       curtype := s_file;
  216.       pvarlist;
  217.    end;
  218.  
  219.  
  220.    procedure pset;
  221.    begin
  222.       gettok;     {consume the SET}
  223.       gettok;     {consume the OF}
  224.  
  225.       pdatatype(stoclass,vars,'/* set of */ ','',false);
  226.    end;
  227.  
  228.  
  229.    procedure pvariant;
  230.    begin
  231.       gettok;     {consume the CASE}
  232.  
  233.       ts := ltok;
  234.       gettok;     {consume the selector identifier}
  235.  
  236.       if tok = ':' then
  237.       begin
  238.          gettok;     {consume the :}
  239.          write(ofd[level], ltok,' ',ts, ';  /* Variant Selector */');
  240.          gettok;     {consume the selector type}
  241.       end
  242.       else
  243.          write(ofd[level],'/* Variant Selector is ',ts,' */');
  244.  
  245.       if tok <> 'OF' then
  246.          syntax('OF expected (pvariant)');
  247.       gettok;
  248.  
  249.       write(ofd[level],' union { ');
  250.       newline;
  251.  
  252.       while tok <> '}' do
  253.       begin
  254.          ts := pexpr;      {parse the selector constant}
  255.          while tok = ',' do
  256.          begin
  257.             gettok;
  258.             ts := pexpr;
  259.          end;
  260.  
  261.          gettok;    {consume the :}
  262.  
  263.          write(ofd[level],' struct { ');
  264.          pvar;
  265.          gettok;    {consume the ')'}
  266.  
  267.          write(ofd[level],' } s',ts,';');
  268.  
  269.          if tok = ';' then
  270.             gettok;
  271.       end;
  272.  
  273.       write(ofd[level],' } v;');
  274.       newline;
  275.    end;
  276.  
  277.    procedure precord;
  278.    begin
  279.       write(ofd[level],stoclass,'struct ',vars.id[1],' { ');
  280.  
  281.       pvar;     {process each record member}
  282.  
  283.       if tok = 'CASE' then    {process the variant part, if any}
  284.          pvariant;
  285.  
  286.       puttok;   {output the closing brace}
  287.       gettok;   {and consume it}
  288.  
  289.       curtype := s_struct;
  290.       cursuptype := ss_struct;
  291.       pvarlist; {output any variables of this record type}
  292.  
  293.       {convert a #define into a typedef in case of a forward pointer decl}
  294.       if forward_typedef <> '' then
  295.       begin
  296.          writeln(ofd[level],';');
  297.          writeln(ofd[level],forward_undef);
  298.          write(ofd[level],forward_typedef);
  299.          forward_typedef := '';
  300.       end;
  301.    end;
  302.  
  303.  
  304.    procedure penum;
  305.    begin
  306.       write(ofd[level],stoclass,'enum {  ');
  307.  
  308.       gettok;
  309.       i := 0;
  310.       repeat
  311.          write(ofd[level],ltok);
  312.          inc(i);
  313.          gettok;
  314.       until tok = ')';
  315.  
  316.       write(ofd[level],' }');
  317.       gettok;   {consume the )}
  318.  
  319.       curtype := s_int;
  320.       curlimit := i;
  321.       pvarlist;
  322.    end;
  323.  
  324.  
  325.    procedure pnumber;
  326.    begin
  327.       ts := pexpr;   {consume the lower limit expression}
  328.       if tok <> '..' then
  329.          error('".." expected (pdatatype)');
  330.  
  331.       gettok;        {consume the ..}
  332.       ts := pexpr;   {consume the number}
  333.  
  334.       sym := locatesym(ts);
  335.       if sym <> nil then
  336.          if sym^.limit > 0 then
  337.             ts := ftoa(sym^.limit,0,0);
  338.  
  339.       curtype := s_int;
  340.       curlimit := atoi(ts);
  341.       write(ofd[level],stoclass,LJUST('int',identlen),' /* limit=',ts,' */');
  342.       pvarlist;
  343.    end;
  344.  
  345.  
  346.    procedure psimple;
  347.    begin
  348.       ts := psimpletype;
  349.  
  350.       i := pos('^',ts);
  351.       if i <> 0 then
  352.       begin
  353.          delete(ts,i,1);
  354.          prefix := '*';
  355.       end;
  356.  
  357.       if (stoclass = 'typedef ') and (vars.n = 1) and (prefix = '*') then
  358.       begin
  359.          newsym(vars.id[1],curtype,cursuptype,-1,0,curlimit);
  360.          write(ofd[level],'#define ',LJUST(vars.id[1],identlen),' struct ',ts,' *');
  361.          forward_undef := '#undef '+vars.id[1];
  362.          forward_typedef := 'typedef struct '+ts+' *'+vars.id[1];
  363.          addsemi := false;
  364.       end
  365.       else
  366.  
  367.       begin
  368.          write(ofd[level],stoclass,LJUST(ts,identlen));
  369.          pvarlist;
  370.       end;
  371.    end;
  372.  
  373.  
  374. begin
  375.    curlimit := 0;
  376.  
  377.    if tok = 'EXTERNAL' then
  378.    begin
  379.       gettok;     {consume the EXTERNAL}
  380.       stoclass := 'extern '+stoclass;
  381.    end;
  382.  
  383.    if tok = 'ARRAY' then
  384.       parray;
  385.  
  386.    if tok = 'STRING'        then pstring
  387.    else if tok = 'TEXT'     then ptext
  388.    else if tok = 'FILE'     then pfile
  389.    else if tok = 'SET'      then pset
  390.    else if tok = '('        then penum
  391.    else if tok = 'RECORD'   then precord
  392.    else if toktype = number then pnumber
  393.    else psimple;
  394.         
  395.    if addsemi then
  396.       write(ofd[level],';');
  397.  
  398.    if tok = ';' then
  399.       gettok;
  400. end;
  401.  
  402.  
  403. (********************************************************************)
  404. (*
  405.  * declaration keyword processors
  406.  *   const, type, var, label
  407.  *
  408.  * all enter with tok=section type
  409.  * exit with tok=new section or begin or proc or func
  410.  *
  411.  *)
  412.  
  413. procedure pconst;
  414.    {parse and translate a constant section}
  415. var
  416.    vars:   paramlist;
  417.    parlev: integer;
  418.    exp:    string80;
  419.  
  420. begin
  421.    gettok;
  422.  
  423.    while (toktype <> keyword) do
  424.    begin
  425.       nospace := false;
  426.       vars.n := 1;
  427.       vars.id[1] := ltok;
  428.  
  429.       gettok;    {consume the id}
  430.  
  431.       if tok = '=' then     {untyped constant}
  432.       begin
  433.          gettok;   {consume the =}
  434.  
  435.          exp := pexpr;
  436.          case exprtype(exp) of
  437.             'c': curtype := s_char;
  438.             'f': curtype := s_double;
  439.             's': curtype := s_string;
  440.             else curtype := s_int;
  441.          end;
  442.  
  443.          write(ofd[level],'#define ',LJUST(vars.id[1],identlen),
  444.                           ' ',LJUST(exp,identlen));
  445.  
  446.          newsym(vars.id[1],curtype,ss_const,-1,0,{0}atoi(exp));
  447.  
  448.          gettok;   {consume the ;}
  449.       end
  450.       else
  451.  
  452.       begin               {typed constants}
  453.  
  454.          gettok;   {consume the :}
  455.  
  456.          pdatatype('static ',vars,'','',false);
  457.  
  458.          gettok;   {consume the =}
  459.  
  460.          write(ofd[level],' = ');
  461.          parlev := 0;
  462.  
  463.          repeat
  464.             if tok = '(' then
  465.             begin
  466.                inc(parlev);
  467.                write(ofd[level],'{');
  468.                gettok;
  469.             end
  470.             else
  471.  
  472.             if tok = ')' then
  473.             begin
  474.                dec(parlev);
  475.                write(ofd[level],'}');
  476.                gettok;
  477.             end
  478.             else
  479.  
  480.             if tok = ',' then
  481.             begin
  482.                puttok;
  483.                gettok;
  484.             end
  485.             else
  486.  
  487.             if (parlev > 0) and (tok = ';') then
  488.             begin
  489.                write(ofd[level],',');
  490.                gettok;
  491.             end
  492.             else
  493.  
  494.             if tok <> ';' then
  495.             begin
  496.                exp := pexpr;
  497.                if tok = ':' then
  498.                   gettok   {discard 'member-identifier :'}
  499.                else
  500.                   write(ofd[level],exp);
  501.             end;
  502.  
  503.          until (tok = ';') and (parlev = 0);
  504.  
  505.          puttok;      {output the final ;}
  506.          gettok;
  507.       end;
  508.    end;
  509. end;
  510.  
  511.  
  512. (********************************************************************)
  513. procedure ptype;
  514.    {parse and translate a type section}
  515. var
  516.    vars: paramlist;
  517.  
  518. begin
  519.    gettok;
  520.  
  521.    while (toktype <> keyword) do
  522.    begin
  523.       vars.n := 1;
  524.       vars.id[1] := usetok;
  525.  
  526.       if tok = '=' then
  527.          gettok
  528.       else
  529.          syntax('"=" expected (ptype)');
  530.  
  531.       nospace := false;
  532.       pdatatype('typedef ',vars,'','',true);
  533.    end;
  534.  
  535. end;
  536.  
  537.  
  538. (********************************************************************)
  539. procedure pvar;
  540.    {parse and translate a variable section}
  541. var
  542.    vars:  paramlist;
  543. begin
  544.  
  545.    vars.n := 0;
  546.    gettok;
  547.  
  548.    while (toktype <> keyword) and (tok <> '}') and (tok <> ')') do
  549.    begin
  550.       nospace := true;
  551.  
  552.       repeat
  553.          if tok = ',' then
  554.             gettok;
  555.  
  556.          inc(vars.n);
  557.          vars.id[vars.n] := ltok;
  558.          gettok;
  559.       until tok <> ',';
  560.  
  561.       if tok <> ':' then
  562.          syntax('":" expected (pvar)')
  563.       else
  564.          gettok;   {consume the :}
  565.  
  566.       nospace := false;
  567.       pdatatype('',vars,'','',true);
  568.       vars.n := 0;
  569.    end;
  570. end;
  571.  
  572.  
  573. (********************************************************************)
  574. procedure plabel;
  575.    {parse (and throw away) a label section}
  576. begin
  577.  
  578.    while tok <> ';' do
  579.       gettok;
  580.  
  581.    gettok;
  582. end;
  583.